home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol117 / updatmar.bas (.txt) < prev    next >
Encoding:
GW-BASIC  |  1986-12-15  |  9.3 KB  |  360 lines
  1. 90  WIDTH "scrn:", 80
  2. 95  SCREEN 0,1,0,0
  3. 100  TITLE$ = "Update the Marriages File Program"
  4. 105  TITLE$ = TITLE$ + " ON DISPLAY"
  5. 110  VERSION$ = "Version 3.0"
  6. 115  COPY1$ = "Copyright (c) 1983, 1984, 1985, by:"
  7. 120  COPY2$ = "Melvin O. Duke"
  8. 125  PRICE$ = "$35"
  9. 130  ADDR1$ = "Melvin O. Duke"
  10. 135  ADDR2$ = "P. O. Box 20836"
  11. 140  ADDR3$ = "San Jose, CA  95160"
  12. 145  REM Dimension Statements go here
  13. 170  REM Produce the first screen
  14. 175  KEY OFF : CLS
  15. 180  REM Draw the outer double box
  16. 185  R1 = 1 : C1 = 1 : R2 = 24 : C2 = 79 : GOSUB 400
  17. 190  REM Find the title location
  18. 195  TITLE.POS = 40 - INT(LEN(TITLE$)/2)
  19. 200  REM Draw the title box
  20. 205  R1=3:C1=TITLE.POS-2:R2=6:C2=TITLE.POS+LEN(TITLE$)+1:GOSUB 600
  21. 210  REM Print the title
  22. 215  LOCATE 4,TITLE.POS : PRINT TITLE$
  23. 220  LOCATE 5,40-INT(LEN(VERSION$)/2) :  PRINT VERSION$;
  24. 225  REM Draw the Contribution box
  25. 230  R1 = 8 : C1 = 19 : R2 = 17 : C2 = 62 : GOSUB 400
  26. 235  REM Request the Contribution
  27. 240  LOCATE 9,23 : PRINT "If you are using these programs, and"
  28. 245  LOCATE 10,21 : PRINT "finding them of value, your contribution"
  29. 250  LOCATE 11,23 : PRINT "("+PRICE$+" suggested) will be anticipated."
  30. 255  REM Draw the Mailing Label
  31. 260  R1 = 12 : C1 = 28 : R2 = 16 : C2 = 52 : GOSUB 600
  32. 265  REM Print the Name and Address
  33. 270  LOCATE 13,40-INT(LEN(ADDR1$)/2) :  PRINT ADDR1$;
  34. 275  LOCATE 14,40-INT(LEN(ADDR2$)/2) :  PRINT ADDR2$;
  35. 280  LOCATE 15,40-INT(LEN(ADDR3$)/2) :  PRINT ADDR3$;
  36. 285  REM Draw the Copyright box
  37. 290  R1 = 19 : C1 = 21 : R2 = 22 : C2 = 59 : GOSUB 400
  38. 295  REM Print the Copyright
  39. 300  LOCATE 20,40-INT(LEN(COPY1$)/2) :  PRINT COPY1$;
  40. 305  LOCATE 21,40-INT(LEN(COPY2$)/2) :  PRINT COPY2$;
  41. 310  GOTO 740
  42. 400  REM subroutine to print a double box
  43. 405  COLOR 5
  44. 410  FOR I = R1 + 1 TO R2 - 1
  45. 420   LOCATE I, C1 : PRINT CHR$(186);
  46. 430   LOCATE I, C2 : PRINT CHR$(186);
  47. 440  NEXT I
  48. 450  FOR J = C1 + 1 TO C2 - 1
  49. 460   LOCATE R1, J : PRINT CHR$(205);
  50. 470   LOCATE R2, J : PRINT CHR$(205);
  51. 480  NEXT J
  52. 490   LOCATE R1, C1 : PRINT CHR$(201);
  53. 500   LOCATE R1, C2 : PRINT CHR$(187);
  54. 510   LOCATE R2, C1 : PRINT CHR$(200);
  55. 520   LOCATE R2, C2 : PRINT CHR$(188);
  56. 525  COLOR 7
  57. 530  RETURN
  58. 600  REM subroutine to print a single box
  59. 605  COLOR 3
  60. 610  FOR I = R1 + 1 TO R2 - 1
  61. 620   LOCATE I, C1 : PRINT CHR$(179);
  62. 630   LOCATE I, C2 : PRINT CHR$(179);
  63. 640  NEXT I
  64. 650  FOR J = C1 + 1 TO C2 - 1
  65. 660   LOCATE R1, J : PRINT CHR$(196);
  66. 670   LOCATE R2, J : PRINT CHR$(196);
  67. 680  NEXT J
  68. 690   LOCATE R1, C1 : PRINT CHR$(218);
  69. 700   LOCATE R1, C2 : PRINT CHR$(191);
  70. 710   LOCATE R2, C1 : PRINT CHR$(192);
  71. 720   LOCATE R2, C2 : PRINT CHR$(217);
  72. 725  COLOR 7
  73. 730  RETURN
  74. 740  REM ask user to press a key to continue
  75. 750  LOCATE 25,1
  76. 760  PRINT "Have Data Diskette(s) in Place, then Press any key to continue.";
  77. 770  K$ = INKEY$ : IF K$ = "" THEN 770
  78. 780  CLS
  79. 840  CLS
  80. 1000  REM Update the Marriage File Program
  81. 1010  REM By:  Melvin O. Duke.  Last Updated:  24 December 1984.
  82. 1015  REM Open the Marriages File
  83. 1020  OPEN "a:marrfile" AS #2 LEN = 128
  84. 1025  REM Open the Persons File
  85. 1026  OPEN "a:persfile" AS #1 LEN = 256
  86. 1027  FIELD 1, 5 AS F1$, 20 AS F2$, 30 AS F3$, 2 AS F4$, 5 AS F5$, 5 AS F6$, 5 AS F7$, 11 AS F8$, 18 AS F9$, 16 AS F10$, 16 AS F11$, 11 AS F12$, 18 AS F13$, 16 AS F14$, 16 AS F15$, 11 AS F16$, 18 AS F17$, 16 AS F18$, 16 AS F19$
  87. 1030  FIELD 2, 5 AS M1$, 5 AS M2$, 5 AS M3$, 5 AS M4$, 11 AS M5$, 18 AS M6$, 16 AS M7$, 16 AS M8$, 45 AS M9$
  88. 1040  REM ask the user for input
  89. 1045  LOCATE 23,1 : PRINT SPACE$(79);
  90. 1050  LOCATE 23,1 : PRINT "(0 to quit, ? to locate unused record)";
  91. 1060  LOCATE 22,1 : PRINT SPACE$(79) : LOCATE 22,1
  92. 1070  INPUT "Enter Record Number of Marriage to Update"; REPLY$
  93. 1071  IF REPLY$ <> "?" THEN 1088
  94. 1072  REM Locate an unused record
  95. 1073  FOUND = 0 : IF REC.NO = 0 THEN REC.NO = 1
  96. 1074  FOR LOOK = REC.NO TO 200
  97. 1075   GET #2, LOOK
  98. 1076   LOCATE 15,1 : PRINT "Searching Record";LOOK;
  99. 1077   TT1 = CVS(M1$)
  100. 1078   IF TT1 > 0 THEN 1080
  101. 1079   FOUND = 1 : REC.NO = LOOK : LOOK = 200
  102. 1080  NEXT LOOK
  103. 1081  IF FOUND = 1 THEN 1110
  104. 1082  PRINT "Unable to find an unused record above record";REC.NO
  105. 1083  PRINT "Either start from record 1 or extend the file"
  106. 1084  PRINT "Press any key to continue"
  107. 1085  GOTO 1040
  108. 1088  REC.NO = VAL(REPLY$)
  109. 1089  IF REC.NO = 0 THEN 2790
  110. 1090  IF REC.NO < 1 OR REC.NO > 200 THEN 1040
  111. 1100  GET #2, REC.NO
  112. 1110  REM Extract information from the file for use
  113. 1120  TT1 = CVS(M1$)
  114. 1130  TT2 = CVS(M2$)
  115. 1140  TT3 = CVS(M3$)
  116. 1150  TT4 = CVS(M4$)
  117. 1160  TT5$ = M5$
  118. 1170  TT6$ = M6$
  119. 1180  TT7$ = M7$
  120. 1190  TT8$ = M8$
  121. 1200  TT9$ = M9$
  122. 1210  CLS
  123. 1220  R1 = 1 : C1 = 1 : R2 = 21 : C2 = 79 : GOSUB 400  'Double box
  124. 1230  R1 = 3 : C1 = 1 : R2 = 3 : C2 = 79 : GOSUB 1620  'Horizontal double
  125. 1240  R1 = 19 : C1 = 1 : R2 = 19 : C2 = 79 : GOSUB 1620  'Horizontal double
  126. 1250  LOCATE  2,33 : PRINT "Marriage Record"
  127. 1270  LOCATE  5, 3 : COLOR 6 : PRINT "Marriage Record-number:";
  128. 1290  LOCATE  7, 3 : PRINT "Husband's Record-number:";
  129. 1300  LOCATE  8, 3 : PRINT "Husband's Name:";
  130. 1310  LOCATE 10, 3 : PRINT "Wife's Record-number:";
  131. 1320  LOCATE 11, 3 : PRINT "Wife's Name:";
  132. 1330  LOCATE 20, 3 : PRINT "Comments:";
  133. 1340  LOCATE  5,42 : PRINT "Marriage Code:";
  134. 1350  LOCATE 13, 3 : COLOR 1 : PRINT "Marriage Statistics:"; : COLOR 6
  135. 1360  LOCATE 14, 3 : PRINT "Marriage-date:";
  136. 1370  LOCATE 15, 3 : PRINT "Marriage-city:";
  137. 1380  LOCATE 16, 3 : PRINT "Marriage-county:";
  138. 1390  LOCATE 17, 3 : PRINT "State/Country:";
  139. 1400  GOSUB 1420 'To print the current information
  140. 1410  GOTO 1900 'For User Input
  141. 1420  REM Print the Information Currently Present
  142. 1430  LOCATE  5,28 : PRINT SPACE$(5);
  143. 1440  LOCATE  5,28 : COLOR 2 : PRINT TT1;
  144. 1450  LOCATE  7,28 : PRINT SPACE$(5);
  145. 1460  LOCATE  7,28 : COLOR 2 : PRINT TT2;
  146. 1462  LOCATE  8,28 : PRINT SPACE$(40);
  147. 1463  REM Obtain the Husband's Record
  148. 1464  IF TT2 = 0 THEN GOSUB 3740 ELSE GET #1, TT2 : GOSUB 3450
  149. 1466  LOCATE  8,28 : COLOR 2 : PRINT T3$ + " " + T2$;
  150. 1470  LOCATE 10,28 : PRINT SPACE$(5);
  151. 1480  LOCATE 10,28 : COLOR 2 : PRINT TT3;
  152. 1482  LOCATE 11,28 : PRINT SPACE$(40);
  153. 1484  REM Obtain the Wife's Record
  154. 1485  IF TT3 = 0 THEN GOSUB 3740 ELSE GET #1, TT3 : GOSUB 3450
  155. 1486  LOCATE 11,28 : COLOR 2 : PRINT T3$ + " " + T2$;
  156. 1490  LOCATE  5,57 : PRINT SPACE$(5);
  157. 1500  LOCATE  5,57 : COLOR 2 : PRINT TT4;
  158. 1510  LOCATE 14,28 : PRINT SPACE$(11);
  159. 1520  LOCATE 14,28 : COLOR 2 : PRINT TT5$;
  160. 1530  LOCATE 15,28 : PRINT SPACE$(18);
  161. 1540  LOCATE 15,28 : COLOR 2 : PRINT TT6$;
  162. 1550  LOCATE 16,28 : PRINT SPACE$(16);
  163. 1560  LOCATE 16,28 : COLOR 2 : PRINT TT7$;
  164. 1570  LOCATE 17,28 : PRINT SPACE$(16);
  165. 1580  LOCATE 17,28 : COLOR 2 : PRINT TT8$;
  166. 1590  LOCATE 20,20 : PRINT SPACE$(45);
  167. 1600  LOCATE 20,20 : COLOR 2 : PRINT TT9$; : COLOR 7
  168. 1610  RETURN
  169. 1620  REM Subroutine to draw a double horizontal line.  Attach to double.
  170. 1625  COLOR 5
  171. 1630  FOR J = C1 + 1 TO C2 - 1
  172. 1640   LOCATE R1,J : PRINT CHR$(205);
  173. 1650  NEXT J
  174. 1660  LOCATE R1,C1 : PRINT CHR$(204);
  175. 1670  LOCATE R1,C2 : PRINT CHR$(185);
  176. 1675  COLOR 7
  177. 1680  RETURN
  178. 1690  REM Subroutine to draw a single horizontal line.  Attach to double.
  179. 1695  COLOR 5
  180. 1700  FOR J = C1 + 1 TO C2 - 1
  181. 1710   LOCATE R1,J : PRINT CHR$(196);
  182. 1720  NEXT J
  183. 1730  LOCATE R1,C1 : PRINT CHR$(199);
  184. 1740  LOCATE R1,C2 : PRINT CHR$(182);
  185. 1745  COLOR 7
  186. 1750  RETURN
  187. 1760  REM Subroutine to draw a double vertical line.  Attach to double.
  188. 1765  COLOR 5
  189. 1770  FOR I = R1 + 1 TO R2 - 1
  190. 1780   LOCATE I,C1 : PRINT CHR$(186);
  191. 1790  NEXT I
  192. 1800  LOCATE R1,C1 : PRINT CHR$(203);
  193. 1810  LOCATE R2,C1 : PRINT CHR$(202);
  194. 1815  COLOR 7
  195. 1820  RETURN
  196. 1830  REM Subroutine to draw a single vertical line.  Attach to double.
  197. 1835  COLOR 5
  198. 1840  FOR I = R1 + 1 TO R2 - 1
  199. 1850   LOCATE I,C1 : PRINT CHR$(179);
  200. 1860  NEXT I
  201. 1870  LOCATE R1,C1 : PRINT CHR$(209);
  202. 1880  LOCATE R2,C1 : PRINT CHR$(207);
  203. 1885  COLOR 7
  204. 1890  RETURN
  205. 1900  REM Routines to Obtain information from the User
  206. 1910  LOCATE 24,1 : PRINT "('enter' to leave alone, '/ enter' to end record, or reply as shown)";
  207. 1920  LOCATE 23,1
  208. 1930  INPUT "Enter the Record Number";REPLY$
  209. 1940  IF REPLY$ = "/" THEN 2560
  210. 1950  IF REPLY$ = "" THEN 1990
  211. 1960  IF ABS(VAL(REPLY$)) = ABS(TT1) THEN 1970 ELSE 1980
  212. 1970  TT1 = VAL(REPLY$)
  213. 1975  IF TT1 < 1 THEN GOSUB 3000 : GOSUB 1420 : GOTO 2560  'Null Record
  214. 1980  GOSUB 1420
  215. 1990  LOCATE 23,1 : PRINT SPACE$(79);
  216. 2000  LOCATE 23,1 : COLOR 7
  217. 2010  INPUT "Enter the Husband's Persons Record-Number";REPLY$
  218. 2020  IF REPLY$ = "/" THEN 2560
  219. 2030  IF REPLY$ = "" THEN 2060
  220. 2040  TT2 = VAL(REPLY$)
  221. 2050  GOSUB 1450
  222. 2060  LOCATE 23,1 : PRINT SPACE$(79);
  223. 2070  LOCATE 23,1 : COLOR 7
  224. 2080  INPUT "Enter the Wife's Persons Record-Number";REPLY$
  225. 2090  IF REPLY$ = "/" THEN 2560
  226. 2100  IF REPLY$ = "" THEN 2130
  227. 2110  TT3 = VAL(REPLY$)
  228. 2120  GOSUB 1470
  229. 2130  LOCATE 23,1 : PRINT SPACE$(79);
  230. 2140  LOCATE 23,1 : COLOR 7
  231. 2150  INPUT "Enter the Marriage Code";REPLY$
  232. 2160  IF REPLY$ = "/" THEN 2560
  233. 2170  IF REPLY$ = "" THEN 2200
  234. 2180  TT4 = VAL(REPLY$)
  235. 2190  GOSUB 1490
  236. 2200  LOCATE 23,1 : PRINT SPACE$(79);
  237. 2210  LOCATE 23,1 : COLOR 7
  238. 2220  INPUT "Enter the Marriage-Date as: dd Mmm yyyy";REPLY$
  239. 2230  IF REPLY$ = "/" THEN 2560
  240. 2240  IF REPLY$ = "" THEN 2270
  241. 2250  TT5$ = REPLY$
  242. 2260  GOSUB 1510
  243. 2270  LOCATE 23,1 : PRINT SPACE$(79);
  244. 2280  LOCATE 23,1 : COLOR 7
  245. 2290  INPUT "Enter the Marriage-city";REPLY$
  246. 2300  IF REPLY$ = "/" THEN 2560
  247. 2310  IF REPLY$ = "" THEN 2340
  248. 2320  TT6$ = REPLY$
  249. 2330  GOSUB 1530
  250. 2340  LOCATE 23,1 : PRINT SPACE$(79);
  251. 2350  LOCATE 23,1 : COLOR 7
  252. 2360  INPUT "Enter the Marriage-county";REPLY$
  253. 2370  IF REPLY$ = "/" THEN 2560
  254. 2380  IF REPLY$ = "" THEN 2410
  255. 2390  TT7$ = REPLY$
  256. 2400  GOSUB 1550
  257. 2410  LOCATE 23,1 : PRINT SPACE$(79);
  258. 2420  LOCATE 23,1 : COLOR 7
  259. 2430  INPUT "Enter the Marriage-State or Country:";REPLY$
  260. 2440  IF REPLY$ = "/" THEN 2560
  261. 2450  IF REPLY$ = "" THEN 2480
  262. 2460  TT8$ = REPLY$
  263. 2470  GOSUB 1570
  264. 2480  LOCATE 23,1 : PRINT SPACE$(79);
  265. 2490  LOCATE 23,1 : COLOR 7
  266. 2500  INPUT "Enter any Comments";REPLY$
  267. 2510  IF REPLY$ = "/" THEN 2560
  268. 2520  IF REPLY$ = "" THEN 2550
  269. 2530  TT9$ = REPLY$
  270. 2540  GOSUB 1590
  271. 2550  REM
  272. 2560  REM Completed this Record
  273. 2570  LOCATE 24,1 : PRINT SPACE$(79);
  274. 2580  LOCATE 23,1 : PRINT SPACE$(79);
  275. 2590  LOCATE 23,1 : COLOR 7
  276. 2600  INPUT "Type s (save), m (more), or f (forget)";REPLY$
  277. 2610  IF LEFT$(REPLY$,1) = "m" THEN LOCATE 23,1 : PRINT SPACE$(79); : GOTO 1900
  278. 2620  IF LEFT$(REPLY$,1) = "f" THEN CLS : GOTO 1040
  279. 2630  IF LEFT$(REPLY$,1) = "s" THEN LOCATE 23,1 : PRINT SPACE$(79); : GOTO 2660
  280. 2640  LOCATE 22,1 : PRINT "Error in reply";
  281. 2650  GOTO 2580
  282. 2660  REM Routine to SAVE the newly updated record
  283. 2670  LSET M1$  = MKS$(TT1)
  284. 2680  LSET M2$  = MKS$(TT2)
  285. 2690  LSET M3$  = MKS$(TT3)
  286. 2700  LSET M4$  = MKS$(TT4)
  287. 2710  LSET M5$  = TT5$
  288. 2720  LSET M6$  = TT6$
  289. 2730  LSET M7$  = TT7$
  290. 2740  LSET M8$  = TT8$
  291. 2750  LSET M9$  = TT9$
  292. 2760  PUT #2, REC.NO
  293. 2770  CLS
  294. 2780  GOTO 1040
  295. 2790  CLOSE #2
  296. 2795  CLOSE #1
  297. 2800  CLS : LOCATE 21,1
  298. 2810  PRINT "End of Program"
  299. 2820  RUN "a:menu"
  300. 3000  REM Blank a Negative Record
  301. 3020  TT2 = 0
  302. 3030  TT3 = 0
  303. 3040  TT4 = 0
  304. 3050  TT5$ = ""
  305. 3060  TT6$ = ""
  306. 3070  TT7$ = ""
  307. 3080  TT8$ = ""
  308. 3090  TT9$ = ""
  309. 3100  RETURN
  310. 3450  REM Routine to Extract Personal Information
  311. 3460  T1 = CVS(F1$)
  312. 3470  T2$ = F2$
  313. 3480  FOR J = 1 TO LEN(F2$) -1
  314. 3490   IF RIGHT$(T2$,1)=" " THEN T2$ = LEFT$(T2$,LEN(T2$)-1) ELSE J = LEN(F2$)-1
  315. 3500  T3$ = F3$
  316. 3510  NEXT J
  317. 3520  FOR J = 1 TO LEN(F3$) -1
  318. 3530   IF RIGHT$(T3$,1)=" " THEN T3$ = LEFT$(T3$,LEN(T3$)-1) ELSE J = LEN(F3$)-1
  319. 3540  NEXT J
  320. 3550  T4$ = F4$
  321. 3560  IF T4$ = "M" THEN T4$ = "Male"
  322. 3570  IF T4$ = "F" THEN T4$ = "Female"
  323. 3580  T5 = CVS(F5$)
  324. 3590  T6 = CVS(F6$)
  325. 3600  T7 = CVS(F7$)
  326. 3610  T8$ = F8$
  327. 3620  T9$ = F9$
  328. 3630  T10$ = F10$
  329. 3640  T11$ = F11$
  330. 3650  T12$ = F12$
  331. 3660  T13$ = F13$
  332. 3670  T14$ = F14$
  333. 3680  T15$ = F15$
  334. 3690  T16$ = F16$
  335. 3700  T17$ = F17$
  336. 3710  T18$ = F18$
  337. 3720  T19$ = F19$
  338. 3730  RETURN
  339. 3740  REM Blank out a Record
  340. 3750  T1 = 0
  341. 3760  T2$ = ""
  342. 3770  T3$ = ""
  343. 3780  T4$ = ""
  344. 3790  T5 = 0
  345. 3800  T6 = 0
  346. 3810  T7 = 0
  347. 3820  T8$ = ""
  348. 3830  T9$ = ""
  349. 3840  T10$ = ""
  350. 3850  T11$ = ""
  351. 3860  T12$ = ""
  352. 3870  T13$ = ""
  353. 3880  T14$ = ""
  354. 3890  T15$ = ""
  355. 3900  T16$ = ""
  356. 3910  T17$ = ""
  357. 3920  T18$ = ""
  358. 3930  T19$ = ""
  359. 3940  RETURN
  360.